;; -*- Mode:LISP; Package:MICRO-ASSEMBLER; Base:8 -*-
;       ** (c) Copyright 1980 Massachusetts Institute of Technology **

(PROCLAIM '(SPECIAL SPECIAL-OUT-FILE))

(PROCLAIM '(SPECIAL RACMO RADMO RAAMO
                    AREA-LIST COLD-LOAD-AREA-SIZES PAGE-SIZE CONSLP-INPUT CONSLP-OUTPUT))

;;; DEFVARs are in CADRLP.
(PROCLAIM '(SPECIAL A-MEM I-MEM D-MEM MICRO-CODE-SYMBOL-IMAGE))

(DEFUN DUMP-MEM-ARRAY (ARRAYP RA-ORG OUT-FILE)
  (PROG (IDX LIM TEM)
        (SETQ IDX 0)
        (SETQ LIM (CADR (ARRAYDIMS ARRAYP)))
  L     (COND ((NOT (< IDX LIM))
                (RETURN T))
              ((SETQ TEM (ARRAYCALL T ARRAYP IDX))
                (PRIN1 (+ RA-ORG IDX) OUT-FILE)
                (PRINC " "  OUT-FILE)
                (PRIN-16 TEM OUT-FILE)
                (TERPRI OUT-FILE)))
        (INCF IDX)
        (GO L)))

(DEFUN CONS-DUMP-ARRAY (ARRAYP OUT-FILE)
  (PROG (IDX LIM)
        (SETQ IDX 0)
        (SETQ LIM (CADR (ARRAYDIMS ARRAYP)))
  L     (COND ((NOT (< IDX LIM))
                (TERPRI OUT-FILE)
                (RETURN T)))
        (PRINT (ARRAYCALL T ARRAYP IDX) OUT-FILE)
        (INCF IDX)
        (GO L)))

(DEFUN PRIN-16 (NUM OUT-FILE)
  (COND ((MINUSP NUM) (SETQ NUM (PLUS NUM #o40000000000))))
  ;; Turn it into a 32 bit +ve number
  (PRIN1 (LDB (byte #o20 #o40) NUM) OUT-FILE)
  (PRINC " " OUT-FILE)
  (PRIN1 (LDB (byte #o20 #o20) NUM) OUT-FILE)
  (PRINC " " OUT-FILE)
  (PRIN1 (LDB (byte #o20 0) NUM) OUT-FILE)
  (PRINC " " OUT-FILE))

(DEFUN CONS-DUMP-MEMORIES NIL
  (LET ((*PACKAGE* (PKG-FIND-PACKAGE "MICRO-ASSEMBLER")))
    (unless (BOUNDP 'RACMO)
      (READFILE "SYS:CC;CADREG LISP >" *PACKAGE*))
    (with-open-file (OUT-FILE (FS:MAKE-PATHNAME ':HOST "SYS"
                                                ':DIRECTORY "UBIN"
                                                ':NAME (STRING CONSLP-OUTPUT)
                                                ':TYPE "ULOAD"
                                                ':VERSION ':NEWEST)
                              :direction :output)
      (DUMP-MEM-ARRAY I-MEM RACMO OUT-FILE)
      (DUMP-MEM-ARRAY D-MEM RADMO OUT-FILE)
      (DUMP-MEM-ARRAY A-MEM RAAMO OUT-FILE)
      (TERPRI OUT-FILE)
      (unless (NULL (AREF MICRO-CODE-SYMBOL-IMAGE 0))   ;IF HAVE WIPED SYMBOL VECTOR
        (PRINT -3 OUT-FILE)                     ;DUMP MICRO-CODE-SYMBOL AREA
        (PRINT (CONS-DUMP-FIND-AREA-ORIGIN 'MICRO-CODE-SYMBOL-AREA) OUT-FILE))
      (CONS-DUMP-ARRAY MICRO-CODE-SYMBOL-IMAGE OUT-FILE)
      (PRINT -2 OUT-FILE)                       ;NOW DUMP SYMBOLS
      (TERPRI OUT-FILE)
      (CONS-DUMP-SYMBOLS OUT-FILE)
      (PRINT -1 OUT-FILE)))             ;EOF
  t)

(DEFUN CONS-DUMP-FIND-AREA-ORIGIN (AREA)
  (PROG (ADR LST TEM)
        (SETQ ADR 0)
        (SETQ LST AREA-LIST)
   L    (COND ((NULL LST)(BREAK "CANT-FIND-AREA-ORIGIN"))
              ((EQ (CAR LST) AREA) (RETURN ADR))
              (T (OR (SETQ TEM (LIST-ASSQ (CAR LST) COLD-LOAD-AREA-SIZES))
                                      (SETQ TEM 1))))
        (SETQ ADR (+ ADR (* TEM PAGE-SIZE)))
        (SETQ LST (CDR LST))
        (GO L)))

(DEFUN LIST-ASSQ (ITEM IN-LIST)
  (PROG NIL
    L   (COND ((NULL IN-LIST) (RETURN NIL))
              ((EQ ITEM (CAR IN-LIST))
                (RETURN (CADR IN-LIST))))
        (SETQ IN-LIST (CDDR IN-LIST))
        (GO L)))

(DEFUN CONS-DUMP-SYMBOLS (SPECIAL-OUT-FILE)
        (MAPATOMS (FUNCTION CONS-LAP-DUMP-SYMTAB-ELEMENT))
)

(DEFUN CONS-LAP-DUMP-SYMTAB-ELEMENT (SYM)
  (PROG (VAL DMP-TYPE TEM
;; not needed after building 99
         (*PRINT-GENSYM* NIL))  ;Somehow DMP-TYPE can be an uninterned symbol named NUMBER.
        (SETQ VAL (GET SYM 'CONS-LAP-USER-SYMBOL))
    L   (COND ((NULL VAL) (RETURN NIL))
              ((NUMBERP VAL)
                (SETQ DMP-TYPE 'NUMBER))
              ((ATOM VAL)
                (SETQ VAL (CONS-LAP-SYMEVAL VAL))
                (GO L))
             ((AND (SETQ TEM (ASSQ (CAR VAL)
                        '( (I-MEM JUMP-ADDRESS-MULTIPLIER)
                           (D-MEM DISPATCH-ADDRESS-MULTIPLIER)
                           (A-MEM A-SOURCE-MULTIPLIER)
                           (M-MEM M-SOURCE-MULTIPLIER))))
                   (EQ (CAADR VAL) 'FIELD)
                   (EQ (CADADR VAL) (CADR TEM)))
              (SETQ DMP-TYPE (CAR VAL) VAL (CADDR (CADR VAL))))
             (T (RETURN NIL)))
        (PRIN1 SYM SPECIAL-OUT-FILE)
        (PRINC " "  SPECIAL-OUT-FILE)
        (PRIN1 DMP-TYPE SPECIAL-OUT-FILE)
        (PRINC " "  SPECIAL-OUT-FILE)
        (PRIN1 VAL SPECIAL-OUT-FILE)
        (PRINC " "  SPECIAL-OUT-FILE)
        (TERPRI SPECIAL-OUT-FILE)
        (RETURN T)))
